home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / MacStarter Pascal 1.0 / xWindows definition files / expression.p next >
Encoding:
Text File  |  1993-12-11  |  63.6 KB  |  2,084 lines  |  [TEXT/PJMM]
  1. { Expressions.p, version 1.0, released December 1993. }
  2.  
  3. { by David J. Eck }
  4. {      Department of Mathematics }
  5. {      Hobart and William Smith Colleges }
  6. {      Geneva, NY 14456 }
  7. {      E-mail:  eck@hws.bitnet }
  8.  
  9. { This unit can be used in any way, except that: }
  10. {        (1)  If you distribute the SOURCE CODE, you cannot charge for it. }
  11. {        (2)  If you distribute the source code, modified or unmodified, it must }
  12. {                include the preamble containing my name and address and this restriction, }
  13. {                and it must include a note of any changes made. }
  14. { Note that there is no restriction on distributing programs you write using }
  15. { this unit, or even charging for them. }
  16.  
  17. { This unit has been tested, but not sufficiently to reveal all errors.  I would be }
  18. { happy to receive reports of problems.  However, the unit is provided with no }
  19. { guarantee of correctness or usefulness. }
  20.  
  21.  
  22.  
  23. unit expression;
  24.  
  25. { This unit defines a class EXPRESSION that implements mathematical expressions, }
  26. { along with a number of supporting utility procedures.  Flexibility is provided by }
  27. { some Boolean variables which can be set to determine the exact behavior of the }
  28. { unit. }
  29.  
  30. { IMPORTANT NOTE:  If you want to use this unit in a program you MUST include a }
  31. {                              call to the procedure InitExpressions in the initialization }
  32. {                              section of your program. }
  33.  
  34.  
  35. { SPECS:  1)  Expressions can include the operators:  +, -, *, /, and ^. }
  36. {              2)  The available built-in functions are:  sin, cos, tan, cot, csc, sec, }
  37. {                          arcsin,arctan,exp,ln,sqrt,cubert,abs,round,trunc. }
  38. {              3)   By default, brackets and braces can be used, as well as parentheses. }
  39. {                         (You can turn off this option.) }
  40. {              4)  Options that you can turn on include:  factorials, split functions, }
  41. {                         and multiplication by juxtaposition instead of * }
  42. {              5)  You can have user-defined functions with up to 10 arguments. }
  43. {              6)  The word "pi" is reserved to mean the constant π. (The symbol π itself }
  44. {                         can also be used in expressions. }
  45. {              7)  For more information, see the boolean OPTIONS defined below. }
  46.  
  47.  
  48. interface
  49.  
  50. const
  51.  
  52.     symbolNameMaxLength = 20;   { This is the longest a variable or function name can }
  53.           { be; extra characters in a name are discarded on input.  This must be at least }
  54.           { 6 in order to support the names of the standard functions. }
  55.  
  56.     infinity = 1e2000;   { The value of an expression that is undefined will be either }
  57.     errorVal = 1e2001;  {      infinity or errorVal;  errorVal is used when an input }
  58.                                   {      value is not in the domain of a function. }
  59.     infinityRecip = 1e-2000;  { Just for convenience; must be set to 1/infinity }
  60.  
  61.  
  62.  
  63. {-------------------- Definition of the class Expression ------------------------}
  64.  
  65. type
  66.  
  67.     expression = object
  68.             data: handle;  { An encoding of the actual expression, really of type }
  69.                             { ExpressionListHandle, which is hidden in the implementation }
  70.                             { section of this unit.  YOU SHOULD NOT do anything with the }
  71.                             { instance variables of an expression. }
  72.             count: integer;    { number of nodes in the ExpressionListHandle }
  73.             first: integer;     { the number of the "root" node in the ExpressionListHandle }
  74.             procedure createFromString (definition: string;
  75.                                         var errorPosition: integer;
  76.                                         var errorMessage: string);
  77.           { This is the most common way of creating an expression.  The function is }
  78.           { simply defined from the specified string (such as '3*x-sin(y^2)').  If no }
  79.           { error occurs, then the expression is defined and errorPosition is set to -1 }
  80.           { If an error occurs, then errorPosition is set to the position in the string }
  81.           { where the error was found, and errorMessage is set to a string that }
  82.           { describes the error. }
  83.             procedure createFromText (definition: CharsHandle;
  84.                                         var errorPosition: integer;
  85.                                         var errorMessage: string);
  86.           { A limitation on createFromString is that it cannot deal with a definition }
  87.           { containing more than 255 characters.  If that is a problem, you can use }
  88.           { createFromText instead.  Here, the definition is contained in a CharsHandle, }
  89.           { which is a handle to an array of characters that can be of any length. }
  90.           { Some utility procedures are provided below for manipulating CharsHandles. }
  91.             procedure create (definition: ptr;       { pointer to array[0..(charCount-1)] of char }
  92.                                         charCount: integer;
  93.                                         var errorPosition: integer;
  94.                                         var errorMessage: string);
  95.           { This is the basic expression creation procedure, but you probably won't use it }
  96.           { directly; calls to createFromString and createFromText are translated into }
  97.           { calles to this procedure. }
  98.             procedure GetPrintString (var str: string;
  99.                                         var lengthExceeded: boolean);
  100.           { Returns a string representation of the expression.  (This is not necessarily }
  101.           { identical to the string used to create the expression.)   It is possible that }
  102.           { the expression would require more than the 255 character maximum allowed }
  103.           { in a string;  in that case, the parameter lengthExceeded is set to true, and the }
  104.           { first 255 characters are returned in str. }
  105.             procedure GetPrintText (var theText: CharsHandle);
  106.           { Returns a text representation of the string; here, there is no length maximum. }
  107.           { Note: theText must already exist as a handle; you can create a handle using the }
  108.           {          procedure NewChars defined below. }
  109.             procedure kill;
  110.           { Dispose of all storage associated to the expression.  After a call to }
  111.           { "expr.kill" any reference to expr is invalid.  You can reuse the variable }
  112.           { expr by calling new(expr) again first. }
  113.             function value: extended;
  114.           { Returns the value of the expression. }
  115.             function valueWithCases (var cases: handle): extended;
  116.           { This function also returns the value of the expressions, but every time it }
  117.           { evaluates a discontinuous function, it records which branch of the function }
  118.           { was used in the handle, cases.  You can then compare the "cases" from two }
  119.           { successive evaluations of the expression using the procedure SameCases }
  120.           { defined below.  If sameCases is false, it is possibly a discontinuity.  This }
  121.           { is meant for use in graphing functions, and is really a fudge. }
  122.           { NOTE: cases must already exist as a handle when this procedure is called; }
  123.           { You can create a handle with:  cases := NewHandle(0) }
  124.             function isConstant: boolean;
  125.           { Test if this is a constant expression }
  126.         end;
  127.  
  128.  
  129. {------------------------------ OPTIONS ----------------------------------}
  130.  
  131. { The following boolean variables are all set to FALSE by the procedure InitExpressions. }
  132. { Their values affect only the parsing of expressions.  For example, if you have defined }
  133. { a split function, and then you turn the option splitFunctions off, you will still be able }
  134. { to use the existing split functions (but you won't be able to define new ones). }
  135. { If you want to change a value, you should ordinarily do so just after calling }
  136. { InitExpressions.  Of course, you can change the values any time you want in your }
  137. { program, but you should be careful when you do so for some of them, as noted in the }
  138. { individual comments.  }
  139.  
  140. var
  141.  
  142.     singleLetterVariables: boolean;  { if turned on, this restricts variables in expressions }
  143.          { being parsed to consist of a single character.  Even if longer variables exist in the }
  144.          { symbol table, they will be inaccessible.  }
  145.  
  146.     implicitMultiplication: boolean;  { if turned on, then multiplication in expressions }
  147.          { being parsed can be indicated implicitely (i.e. by juxtaposition) as well as }
  148.          { explicitely (by "*").  For example , "speed time" will be interpreted as }
  149.          { "speed * time".   Note that a space is still required between speed and time, }
  150.          { since "speedtime" will be interpreted as a single variable.  However, if you }
  151.          { also turn on the option singleLetterVariables, then things like "2xy" will be }
  152.          { correctly interpreted (as "2*x*y"). }
  153.  
  154.     autoDeclareVariables: boolean;   { by default, when an unknown symbol is encountered }
  155.          { in an expression being parsed, it is considered to be an error.  If you turn on this }
  156.          { option, however, any unknown symbol will be automatically declared to be a }
  157.          { variable with an initial value of 0 }
  158.  
  159.     splitFunctions: boolean;    { if this option is turned on, it is possible to define "split }
  160.          { functions" which have different defintions on different parts of their domain. }
  161.          { The notation for a split function is: }
  162.          {        CASE <condition> : <expression> ;  <condition> : <value> ;  . . . END }
  163.          { For example:    "case  x>0: ln(x);  x<=0: 1 end"    (The final ; is optional.) }
  164.          { Example function definition:  "max(a,b) = CASE  a>b:  a;  a<=b:  b;  END" }
  165.          { When this option is turned on, the words CASE and END are RESERVED.  That is }
  166.          { they cannot be used for any other purpose except to define split functions. }
  167.          { (Varialbles or functions named case or end will be inaccessible.) }
  168.  
  169.     parenthesesOnly: boolean;  { by default, brackets and set braces can be used in }
  170.          { expressions being parsed.  Matching of left bracket to right bracket and left }
  171.          { brace to right brace is enforced, as well as matching of left parenthesis to }
  172.          { right parenthesis.  If you turn on this option, only parentheses will be allowed. }
  173.  
  174.     allowFactorials: boolean;   { If you turn on this option, then the factorial operator }
  175.          { can appear in expressions being parsed.  The notation is the usual one  (for }
  176.          { example:  n! ).  When factorials are evaluated, the operand must be a non- }
  177.          { negative integer, or an error occurs. }
  178.  
  179.     caseSensitive: boolean;   { By default, upper case and lower case letters are considered }
  180.          { to be the same during string comparisons.  For example, sin(X), Sin(x) and }
  181.          { SIN(x) all mean the same thing.  If you want case to matter, you can turn on this }
  182.          { option.   If you do, note that the standard functions are written in lower case. }
  183.  
  184.     extraDataAfterExpression: boolean;  { Ordinarily, an error occurs if extra data is }
  185.          { found in the input after the expression is fully parsed.  Turn on this option if }
  186.          { you don't want this to be an error. }
  187.  
  188.  
  189. {---------------------------- Procedures ----------------------------------}
  190.  
  191. procedure initExpressions;
  192. { This procedure MUST be called before any of the other procedures in the unit are}
  193. { used.  It initializes the symbol table and defined all the built-in functions, as }
  194. { well as the constant e. }
  195.  
  196. procedure DefineFunctionFromString (definition: string;
  197.                             var errorPos: integer;
  198.                             var errorMessage: string);
  199. { The definition should be a string of the form "<name> (<arguments>) = <expression>" }
  200. { (for example, like 'f(x,y)=3*x-sin(y)').  The equals sign is actually optional. }
  201. { This inserts a function <name> into the symbol table with the specified definition.  }
  202. { The function can then be used in subsequent expressions.  You can't redefine a }
  203. { built-in function, and you can't redefine a variable or symbolic constant as a }
  204. { function.  You CAN redefine an existing function, PROVIDED there is the same number }
  205. { of arguments in the new definition as in the old;  if you do redefine a function, any }
  206. { expression that refers to that function will also be effectively changed. }
  207. { If the definition is successful, errorPos is set to -1;  if an error occurs, errorPos }
  208. { is set to indicate the position of the error in the string, and errorMessage is set to }
  209. { a string describing the error. }
  210.  
  211. procedure DefineFunctionFromText (definition: CharsHandle;
  212.                             var errorPos: integer;
  213.                             var errorMessage: string);
  214. { This allows you to define functions when the definition is longer than 255 characters; }
  215. { here, the defintion is given as a CharsHandle; otherwise, the description of this }
  216. { routine is the same as that of DefineFunctionFromString. }
  217.  
  218. procedure DefineFunction (definition: Ptr;
  219.                             charCt: integer;
  220.                             var errorPos: integer;
  221.                             var errorMessage: string);
  222. { The basic function definition procedure, which you will probably have no reason to }
  223. { use.  Calls to DefineFunctionFromText and DefineFunctionFromString are translated }
  224. { into calls to this procedure. }
  225.  
  226. function CreateVariable (name: string;
  227.                             val: extended): integer;
  228. { Add a variable of the specified name, with the specified initial value, to the }
  229. { symbol table.  Thereafter, the variable can be used in expressions.  This functions }
  230. { returns an integer that can be used subsequently to refer to the variable in the procedures }
  231. { SetVariableName and SetVariableValue.  If some error occurs in defining the variable, }
  232. { then a value of -1 is returned by the function.  It is an error to try to redefine an }
  233. { existing symbol.  It is also conceivable (though very unlikely) that an error will }
  234. { occur because you have run out of memory. }
  235.  
  236. procedure SetVariableValue (varRef: integer;
  237.                             val: extended);
  238. { Change the value of an existing variable.  varRef must be a value returned by the }
  239. { procedure CreateVariable when the variable was first created. }
  240.  
  241. procedure SetVariableName (varRef: integer;
  242.                             name: string);
  243. { Change the name of an existing variable.  This procedure does no error checking }
  244. { (so that you could, for example, make two variables have the same name!).  Use this }
  245. { procedure only in limited circumstances.  For example, if your program uses only }
  246. { one or a few variables, and you know what all their names are. }
  247.  
  248. procedure CreateSymbolicConstant (name: string;
  249.                             value: extended;
  250.                             var err: boolean);
  251. { Creates a "symbolic constant", which is like a variable except that its value can't be }
  252. { changed.  The symbolic constant  e  is built in.  (π is also built in, although by a }
  253. { slightly different mechanism, which allows it to be referred to as either π or pi. ) }
  254.  
  255. function sameCases (cases1, cases2: handle): boolean;
  256. { compares two handles returned by the function expression.valueWithCases; if the }
  257. { answer is false, it is possible that there is a "discontinuity" between the two }
  258. { evaluations of the expression.  See the comment on function valueWithCases above. }
  259.  
  260. procedure RealToString (x: extended;
  261.                             var s: string);
  262. { Utility procedure for reasonable string representation of a real number.  The string }
  263. { will not be longer than 12 characters. }
  264.  
  265. function NewChars: CharsHandle;
  266. { Utility procedure for initializing a CharsHandle; All of the above procedures that }
  267. { use CharsHandles require that their parameter already be initialized when the }
  268. { procedure is called; the initial lenght of the array is 0. }
  269.  
  270. function CharsSize (Chars: CharsHandle): longint;
  271. { Utility procedure for checking how many characters there are in the array }
  272. { pointed to by the handle Chars. }
  273. { Chars must already be initialized, for example by using function NewChars. }
  274.  
  275. procedure MakeCharsEmpty (var Chars: CharsHandle);
  276. { Utility procedur for resetting the length of the array pointed to by Chars to 0. }
  277. { Chars must already be initialized, for example by using function NewChars. }
  278.  
  279. procedure AddStringToChars (var Chars: CharsHandle;
  280.                             str: string);
  281. { Utility procedure for adding the characters in the string str onto the end of the }
  282. { array of characters pointed to by Chars. }
  283. { Chars must already be initialized, for example by using function NewChars. }
  284.  
  285.  
  286.  
  287. implementation
  288.  
  289.  
  290. {----------------------- Type definitions for expressions --------------------}
  291.  
  292. type
  293.  
  294.     ExpressionNodeKinds = ( { types of nodes in the binary tree reprsenting an expression}
  295.         binOpNode, {represents an operator with two operands}
  296.         unaryOpNode, {unary minus or built-in function}
  297.         functNode, {call to user-defined function}
  298.         splitFunctionNode, {represents a sub-expression together with a boolean condition on}
  299.                        {  the domain;  this is also used to implement "split" functions in which }
  300.                        {  different definitinons are given on different domains }
  301.         variableNode, {represents a variable  }
  302.         parameterNode, { ref to a param in a user-defined function; appear only in }
  303.                              { the definitions associated with user functions }
  304.         actualParamNode,  { an actual parameter in a function call (a sub expression) }
  305.         symbolicConstantNode, { reference to a defined constant, such as e }
  306.         constantNode, { an actual numeric constant }
  307.         piNode { ref to the constant π }
  308.         );
  309.  
  310.     binOpKinds = (plusOp, minusOp, timesOp, divideOp, powerOp, andOp, orOp, leOp, ltOp, geOp, gtOp, eqOp, neOp);
  311.     unaryOpKinds = (unaryMinusOp, notOp, sinOp, cosOp, tanOp, cotOp, secOp, {}
  312.         cscOp, arcsinOp, arctanOp, expOp, lnOp, roundOp, truncOp, sqrtOp,{}
  313.         cubeRtOp, absOp, factorialOp);
  314.  
  315.     ExpressionNode = record      { one of the nodes in the binary tree rep. of an expression }
  316.             bracket: char;  { parenthesis, brace, or bracket (or space, for no bracket) }
  317.             case kind : ExpressionNodeKinds of
  318.                 binOpNode: (    { operator and operands}
  319.                         theBinOp: binOpKinds;
  320.                         operand1, operand2: integer;  { static pointers to operands }
  321.                 );
  322.                 unaryOpNode: (   {operator/function and operand/argument}
  323.                         theOp: unaryOpKinds;
  324.                         operand: integer;   { static pointer }
  325.                 );
  326.                 functNode: (   { pointer into list of functions; static pointer to argument }
  327.                         definition: integer;    { position of definition in symbolTable }
  328.                         firstArgument: integer;   { ref to first actual parameter; -1 is no params }
  329.                 );
  330.                 splitFunctionNode: (
  331.                         theExpression, theTest: integer;   { pointer to subexpression and domain cond.}
  332.                         nextCase: integer;      { for a split function, the next case subexpression }
  333.                 );
  334.                 variableNode, symbolicConstantNode: (
  335.                         symbol: integer;   { pointer into symbol table }
  336.                 );
  337.                 parameterNode: (
  338.                         number: integer
  339.                 );
  340.                 actualParamNode: (
  341.                         param: integer;
  342.                         nextArgument: integer;
  343.                 );
  344.                 constantNode: (
  345.                         value: extended
  346.                 );
  347.                 piNode: (
  348.                 )
  349.         end;
  350.  
  351.     ExpressionListArray = array[0..1000] of ExpressionNode;  { data for expression is stored }
  352.     ExpressionListPtr = ^ExpressionListArray;   { as a binary tree using static pointers in a}
  353.     ExpressionListHandle = ^ExpressionListPtr;{variable-length array of nodes}
  354.  
  355.  
  356. {---------------------- SYMBOL TABLE STUFF -------------------- }
  357.  
  358.  
  359. type
  360.  
  361.     symbolTableError = (noSymbolTableError, lowMemory, cantDeleteFunction, symbolDoesNotExist, symbolAlreadyExists);
  362.  
  363.     symbolTableKinds = (variableSymbol, functionSymbol, constantSymbol, builtInFunctionSymbol, deletedSymbol, parameterSymbol);
  364.  
  365.     symbolName = string[symbolNameMaxLength];
  366.  
  367.     symbolTableNode = record
  368.             name: symbolName;
  369.             case kind : symbolTableKinds of
  370.                 variableSymbol, constantSymbol: (
  371.                         value: extended
  372.                 );
  373.                 functionSymbol: (
  374.                         parameterCount: integer;
  375.                         definition: expression
  376.                 );
  377.                 parameterSymbol: (
  378.                         paramNum: integer
  379.                 );
  380.                 builtInFunctionSymbol: (
  381.                         theOp: UnaryOpKinds
  382.                 );
  383.                 deletedSymbol: (
  384.                 )
  385.         end;
  386.     symbolTableArray = array[0..100] of symbolTableNode;
  387.     symbolTablePtr = ^symbolTableArray;
  388.     symbolTableHandle = ^symbolTablePtr;
  389.  
  390. var
  391.     ST: symbolTableHandle;
  392.     ST_size: integer;
  393.     ST_count: integer;
  394.     ST_mark: integer;
  395.     nameChars: set of char;
  396.  
  397. procedure MarkSymb;
  398.     begin
  399.         if ST_mark < 0 then
  400.             ST_mark := ST_count;
  401.     end;
  402.  
  403. procedure FreeSymb;
  404.     begin
  405.         if ST_mark >= 0 then
  406.             ST_count := ST_mark;
  407.         ST_mark := -1;
  408.     end;
  409.  
  410. function FindSymb (name: SymbolName): integer;
  411.     var
  412.         i: integer;
  413.     begin
  414.         for i := ST_count - 1 downto 0 do
  415.             if not (ST^^[i].kind = deletedSymbol) & EqualString(ST^^[i].name, name, caseSensitive, caseSensitive) then begin
  416.                     FindSymb := i;
  417.                     EXIT(FindSymb);
  418.                 end;
  419.         FindSymb := -1;
  420.     end;
  421.  
  422. function CreateSymbol (name: SymbolName;
  423.                                 kind: SymbolTableKinds;
  424.                                 var err: SymbolTableError): integer;
  425.     var
  426.         loc, i: integer;
  427.     begin
  428.         loc := FindSymb(name);
  429.         if loc <> -1 then begin
  430.                 err := symbolAlreadyExists;
  431.                 EXIT(CreateSymbol);
  432.             end;
  433.         if (kind <> parameterSymbol) then
  434.             for i := 0 to ST_size - 1 do
  435.                 if ST^^[i].kind = deletedSymbol then begin
  436.                         loc := i;
  437.                         leave
  438.                     end;
  439.         if loc = -1 then begin
  440.                 if ST_count = ST_size then begin
  441.                         SetHandleSize(Handle(ST), (ST_size + 20) * SizeOf(SymbolTableNode));
  442.                         if memError <> noErr then begin
  443.                                 err := lowMemory;
  444.                                 EXIT(CreateSymbol);
  445.                             end;
  446.                         ST_size := ST_size + 20;
  447.                     end;
  448.                 loc := ST_count;
  449.                 ST_count := ST_count + 1;
  450.             end;
  451.         ST^^[loc].name := name;
  452.         ST^^[loc].kind := kind;
  453.         if kind = variableSymbol then
  454.             ST^^[loc].value := 0;
  455.         err := noSymbolTableError;
  456.         CreateSymbol := loc;
  457.     end;
  458.  
  459.  
  460. procedure AddBuiltInFunctions;
  461.     var
  462.         junk: boolean;
  463.     procedure Add (op: unaryOpKinds;
  464.                                     name: SymbolName);
  465.         var
  466.             where: integer;
  467.             err: symbolTableError;
  468.         begin
  469.             where := CreateSymbol(name, builtInFunctionSymbol, err);
  470.             if err <> noSymbolTableError then
  471.                 EXIT(AddBuiltInFunctions);
  472.             ST^^[where].theOp := op;
  473.         end;
  474.     begin
  475.         Add(sinOp, 'sin');
  476.         Add(cosOP, 'cos');
  477.         Add(tanOP, 'tan');
  478.         Add(cscOP, 'csc');
  479.         Add(secOP, 'sec');
  480.         Add(cotOP, 'cot');
  481.         Add(arcsinOP, 'arcsin');
  482.         Add(arctanOP, 'arctan');
  483.         Add(expOP, 'exp');
  484.         Add(lnOP, 'ln');
  485.         Add(roundOP, 'round');
  486.         Add(truncOP, 'trunc');
  487.         Add(sqrtOP, 'sqrt');
  488.         Add(cubertOP, 'cubert');
  489.         Add(absOP, 'abs');
  490.         CreateSymbolicConstant('e', exp(1), junk);
  491.     end;
  492.  
  493.  
  494. procedure initExpressions;
  495.     begin
  496.         singleLetterVariables := false;
  497.         implicitMultiplication := false;
  498.         autoDeclareVariables := false;
  499.         splitFunctions := false;
  500.         parenthesesOnly := false;
  501.         allowFactorials := false;
  502.         caseSensitive := false;
  503.         extraDataAfterExpression := false;
  504.         ST := SymbolTableHandle(NewHandle(20 * SizeOf(SymbolTableNode)));
  505.         ST_size := 20;
  506.         ST_count := 0;
  507.         ST_mark := -1;
  508.         nameChars := ['a'..'z', 'A'..'Z', '0'..'9', '_'];
  509.         AddBuiltInFunctions;
  510.     end;
  511.  
  512. function CreateVariable (name: string;
  513.                                 val: extended): integer;
  514. { returns ref to variable for use in SetVariableName and SetVariableValue }
  515.     var
  516.         err: SymbolTableError;
  517.         symb: integer;
  518.     begin
  519. {$PUSH}
  520. {$R-}
  521.         if length(name) > symbolNameMaxLength then
  522.             name[0] := chr(symbolNameMaxLength);
  523. {$POP}
  524.         symb := CreateSymbol(name, variableSymbol, err);
  525.         if err <> noSymbolTableError then
  526.             CreateVariable := -1
  527.         else begin
  528.                 CreateVariable := Symb;
  529.                 ST^^[symb].value := val;
  530.             end;
  531.     end;
  532.  
  533. procedure SetVariableValue (varRef: integer;
  534.                                 val: extended);
  535.     begin
  536.         if (varRef < 0) | (varRef >= ST_count) | (ST^^[varRef].kind <> variableSymbol) then
  537.             EXIT(SetVariableValue);
  538.         ST^^[varRef].value := val;
  539.     end;
  540.  
  541. procedure SetVariableName (varRef: integer;
  542.                                 name: string);
  543. { for limited use--little error checking }
  544.     begin
  545.         if (varRef < 0) | (varRef >= ST_count) | (ST^^[varRef].kind <> variableSymbol) then
  546.             EXIT(SetVariableName);
  547. {$PUSH}
  548. {$R-}
  549.         if length(name) > symbolNameMaxLength then
  550.             name[0] := chr(symbolNameMaxLength);
  551. {$POP}
  552.         ST^^[varRef].name := name;
  553.     end;
  554.  
  555. procedure CreateSymbolicConstant (name: string;
  556.                                 value: extended;
  557.                                 var err: boolean);
  558.     var
  559.         STerr: SymbolTableError;
  560.         symb: integer;
  561.     begin
  562. {$PUSH}
  563. {$R-}
  564.         if length(name) > symbolNameMaxLength then
  565.             name[0] := chr(symbolNameMaxLength);
  566. {$POP}
  567.         symb := CreateSymbol(name, constantSymbol, STerr);
  568.         if STerr <> noSymbolTableError then
  569.             err := true
  570.         else begin
  571.                 err := false;
  572.                 ST^^[symb].value := value;
  573.             end;
  574.     end;
  575.  
  576. {-------------------END OF  SYMBOL TABLE STUFF ------------------ }
  577.  
  578. function NewChars: CharsHandle;    { SOME CHARSHANDLE UTILITIES }
  579.     begin
  580.         NewChars := CharsHandle(NewHandle(0));
  581.     end;
  582.  
  583. procedure MakeCharsEmpty (var Chars: CharsHandle);
  584.     begin
  585.         SetHandleSize(Handle(Chars), 0);
  586.     end;
  587.  
  588. function CharsSize (Chars: CharsHandle): longint;
  589.     begin
  590.         CharsSize := GetHandleSize(handle(Chars));
  591.     end;
  592.  
  593. procedure AddStringToChars (var Chars: CharsHandle;
  594.                                 str: string);
  595.     var
  596.         start, i: longint;
  597.     begin
  598.         start := GetHandleSize(handle(Chars));
  599.         SetHandleSize(handle(Chars), start + length(str));
  600.         if memError = noErr then
  601.             for i := 1 to length(str) do
  602.                 Chars^^[start + i - 1] := str[i];
  603.     end;
  604.  
  605.  
  606. {---------------------String-reading procs-----------------------}
  607.  
  608.     const
  609.         endOfDataToken = chr(0);
  610.         errorToken = chr(1);
  611.         numericToken = chr(2);
  612.         badNumericToken = chr(3);
  613.         caseToken = chr(4);
  614.         endToken = chr(5);
  615.         implicitStarToken = chr(6);
  616.  
  617.  
  618.     var
  619.         parseData: CharsPtr;
  620.         parseSize: integer;
  621.         pos: integer;
  622.         tokenAvailable: boolean;
  623.         theToken: SymbolName;
  624.         tokenVal: extended;
  625.  
  626.  
  627.  
  628. function nextCh: char;
  629.     begin
  630.         if pos >= parseSize then
  631.             nextCh := endOfDataToken
  632.         else
  633.             nextCh := parseData^[pos]
  634.     end;
  635.  
  636. function getCh: char;
  637.     begin
  638.         if pos = parseSize then
  639.             getCh := endOfDataToken
  640.         else begin
  641.                 getCh := parseData^[pos];
  642.                 pos := pos + 1
  643.             end;
  644.     end;
  645.  
  646. procedure GetWord (var name: SymbolName);
  647. { assumes next char is a letter! }
  648.     var
  649.         ch: char;
  650.         ct: integer;
  651.         savePos: integer;
  652.     begin
  653.         ct := 0;
  654.         name := '';
  655.         savePos := pos;
  656.         while (ct < SymbolNameMaxLength) & (nextCh in nameChars) do begin
  657.                 name := Concat(name, getCh);
  658.                 ct := ct + 1
  659.             end;
  660.         while (nextCh in nameChars) do
  661.             ch := getCh;
  662.         if EqualString(name, 'pi', false, false) then
  663.             name := 'π'
  664.         else if splitFunctions then begin
  665.                 if EqualString(name, 'case', false, false) then
  666.                     name := caseToken
  667.                 else if EqualString(name, 'end', false, false) then
  668.                     name := endToken
  669.                 else if EqualString(name, 'and', false, false) then
  670.                     name := '&'
  671.                 else if EqualString(name, 'or', false, false) then
  672.                     name := '|'
  673.                 else if EqualString(name, 'not', false, false) then
  674.                     name := '~'
  675.                 else if singleLetterVariables & (FindSymb(name) = -1) then begin
  676.                         name := name[1];
  677.                         pos := savePos + 1;
  678.                     end;
  679.             end
  680.         else if singleLetterVariables & (FindSymb(name) = -1) then begin
  681.                 name := name[1];
  682.                 pos := savePos + 1;
  683.             end;
  684.     end;
  685.  
  686. procedure GetNum (var val: extended;
  687.                                 var good: boolean);
  688.     var
  689.         num: string;
  690.         ct: integer;
  691.     begin
  692.         num := '';
  693.         good := false;
  694.         while (length(num) < 255) & (nextCh in ['0'..'9']) do
  695.             num := Concat(num, getCh);
  696.         if nextCh = '.' then begin
  697.                 if num = '' then begin
  698.                         num := getCh;
  699.                         if not (nextCh in ['0'..'9']) then
  700.                             EXIT(GetNum)  { '.' with no digits on either side of it }
  701.                     end
  702.                 else if length(num) < 255 then
  703.                     num := Concat(num, getCh)
  704.             end;
  705.         while (length(num) < 255) & (nextCh in ['0'..'9']) do
  706.             num := Concat(num, getCh);
  707.         if (length(num) < 255) & ((nextCh = 'e') | (nextCh = 'E')) then begin
  708.                 num := Concat(num, getCh);
  709.                 if (length(num) < 255) & ((nextCh = '-') | (nextCh = '+')) then
  710.                     num := Concat(num, getCh);
  711.                 ct := 0;
  712.                 while (length(num) < 255) & (nextCh in ['0'..'9']) do begin
  713.                         num := Concat(num, getCh);
  714.                         ct := ct + 1
  715.                     end;
  716.                 if (ct = 0) | (ct > 3) then
  717.                     EXIT(GetNum);  { bad number of digits in exponent }
  718.             end;
  719.         if length(num) = 255 then
  720.             EXIT(GetNum); {number too long}
  721.         IOCheck(false);
  722.         ReadString(num, val);
  723.         IOCheck(true);
  724.         if IOResult <> 0 then
  725.             EXIT(GetNum); { something strange is wrong in the number }
  726.         good := true;
  727.     end;
  728.  
  729. procedure look (var token: SymbolName);
  730.     var
  731.         ch: char;
  732.         good: boolean;
  733.     begin
  734.         if tokenAvailable then
  735.             token := theToken
  736.         else begin
  737.                 ch := nextCh;
  738.                 while ch in [' ', chr(9), chr(13), chr(3)] do begin
  739.                         ch := getCh;
  740.                         ch := nextCh;
  741.                     end;
  742.                 if ch in ['0'..'9', '.'] then begin
  743.                         GetNum(tokenVal, good);
  744.                         if good then
  745.                             theToken := numericToken
  746.                         else
  747.                             theToken := badNumericToken
  748.                     end
  749.                 else if ch in ['a'..'z', 'A'..'Z'] then
  750.                     GetWord(theToken)
  751.                 else if ch in [endOfDataToken, 'π', '+', '-', '*', '^', '/', '(', ')', '[', ']', '{', '}', '='] then
  752.                     theToken := GetCh
  753.                 else if allowFactorials & (ch = '!') then
  754.                     theToken := GetCh
  755.                 else if splitFunctions & (ch in ['~', '<', '>', '≥', '≤', '≠', '&', '|', ':', ';', ',']) then begin
  756.                         theToken := getCh;
  757.                         if (theToken = '>') & (nextCh = '=') then begin
  758.                                 theToken := '≥';
  759.                                 ch := getCh
  760.                             end
  761.                         else if (theToken = '<') & (nextCh = '=') then begin
  762.                                 theToken := '≤';
  763.                                 ch := getCh
  764.                             end
  765.                         else if (theToken = '<') & (nextCh = '>') then begin
  766.                                 theToken := '≠';
  767.                                 ch := getCh
  768.                             end
  769.                     end
  770.                 else begin
  771.                         theToken := errorToken;
  772.                         ch := getCh
  773.                     end;
  774.                 token := theToken;
  775.                 tokenAvailable := true;
  776.             end
  777.     end;
  778.  
  779. procedure GetToken (var token: symbolName);
  780.     begin
  781.         Look(token);
  782.         TokenAvailable := false;
  783.     end;
  784.  
  785.  
  786. {----------------end of tokenization procedures--------------------}
  787. function RightBracket (left: char): char;
  788.     begin
  789.         if left = '(' then
  790.             RightBracket := ')'
  791.         else if left = '{' then
  792.             RightBracket := '}'
  793.         else if left = '[' then
  794.             RightBracket := ']';
  795.     end;
  796.  
  797. procedure DefineFunctionFromString (definition: string;
  798.                                 var errorPos: integer;
  799.                                 var errorMessage: string);
  800.     begin
  801.         if definition = '' then begin
  802.                 errorPos := 0;
  803.                 errorMessage := 'Empty input provided for function definition.';
  804.             end
  805.         else
  806.             DefineFunction(@definition[1], length(definition), errorPos, errorMessage);
  807.     end;
  808.  
  809. procedure DefineFunctionFromText (definition: CharsHandle;
  810.                                 var errorPos: integer;
  811.                                 var errorMessage: string);
  812.     begin
  813.         Hlock(Handle(definition));
  814.         DefineFunction(Ptr(definition^), CharsSize(definition), errorPos, errorMessage);
  815.         HUnlock(Handle(definition));
  816.     end;
  817.  
  818. procedure DefineFunction (definition: Ptr;
  819.                                 charCt: integer;
  820.                                 var errorPos: integer;
  821.                                 var errorMessage: string);
  822.     var
  823.         name, tok: SymbolName;
  824.         paramCt: integer;
  825.         err: SymbolTableError;
  826.         exp: expression;
  827.         symb, func: integer;
  828.         nameExists: boolean;
  829.     procedure ExitWithError (message: string);
  830.         begin
  831.             errorPos := pos;
  832.             errorMessage := message;
  833.             FreeSymb;
  834.             EXIT(DefineFunction);
  835.         end;
  836.     begin
  837.         parseData := CharsPtr(definition);
  838.         parseSize := charCt;
  839.         pos := 0;
  840.         TokenAvailable := false;
  841.         GetToken(name);
  842.         if not (name[1] in ['a'..'z', 'A'..'Z']) then
  843.             ExitWithError('Illegal name specified for function begin defined.');
  844.         symb := FindSymb(name);
  845.         if symb = -1 then
  846.             NameExists := false
  847.         else if ST^^[symb].kind <> functionSymbol then
  848.             ExitWithError('The name for the function being defined is already in use.')
  849.         else begin
  850.                 NameExists := true;
  851.                 func := symb
  852.             end;
  853.         GetToken(tok);
  854.         if tok <> '(' then
  855.             ExitWithError('Expected a left parenthesis to begin the function''s argument list.');
  856.         GetToken(tok);
  857.         if not (tok[1] in ['a'..'z', 'A'..'Z']) then
  858.             ExitWithError('Expected a name for the function''s first argument.');
  859.         paramCt := 0;
  860.         MarkSymb;
  861.         repeat
  862.             paramCt := paramCt + 1;
  863.             if paramCt > 10 then
  864.                 ExitWithError('Too many arguments for this function; maximum is ten.');
  865.             symb := CreateSymbol(tok, parameterSymbol, err);
  866.             if err = lowMemory then
  867.                 ExitWithError('Ran out of memory.')
  868.             else if err = symbolAlreadyExists then
  869.                 ExitWithError('You can''t have two arguments with the same name.');
  870.             ST^^[symb].paramNum := paramCt;
  871.             GetToken(tok);
  872.             if (tok <> ',') & (tok <> ')') then
  873.                 ExitWithError('Expected either a comma or a right parenthesis.');
  874.             if tok = ',' then begin
  875.                     GetToken(tok);
  876.                     if not (tok[1] in ['a'..'z', 'A'..'Z']) then
  877.                         ExitWithError('Expected a name for the function''s next argument.');
  878.                 end;
  879.         until tok = ')';
  880.         look(tok);
  881.         if tok = '=' then
  882.             GetToken(tok);
  883.         if nameExists & (ST^^[func].parameterCount <> paramCt) then
  884.             ExitWithError('Attempt to redefine a function with a different number of arguments.');
  885.         new(exp);
  886.         definition := Ptr(longint(definition) + pos);
  887.         exp.create(definition, charCt - pos, errorPos, errorMessage);
  888.         FreeSymb;
  889.         if errorPos >= 0 then begin
  890.                 errorPos := errorPos + pos;
  891.                 dispose(exp);
  892.                 Exit(DefineFunction);
  893.             end;
  894.         if not nameExists then begin
  895.                 func := CreateSymbol(name, functionSymbol, err);
  896.                 if err <> noSymbolTableError then begin
  897.                         exp.kill;
  898.                         ExitWithError('Ran out of memory.');
  899.                     end;
  900.             end;
  901.         ST^^[func].parameterCount := paramCt;
  902.         if nameExists then
  903.             ST^^[func].definition.kill;
  904.         ST^^[func].definition := exp;
  905.     end;
  906.  
  907. procedure expression.create (definition: ptr;       { pointer to array[0...] of char }
  908.                                 charCount: integer;
  909.                                 var errorPosition: integer;   { -1 if no error }
  910.                                 var errorMessage: string); { unchanged if no error }
  911.     var
  912.         size: integer;
  913.         exp: expressionListHandle;
  914.     procedure ExitWithError (message: string);
  915.         begin
  916.             DisposHandle(data);
  917.             errorPosition := pos;
  918.             errorMessage := message;
  919.             EXIT(create);
  920.         end;
  921.     function NewNode: integer;
  922.         begin
  923.             if count = size then begin
  924.                     SetHandleSize(data, (size + 20) * SizeOf(expressionNode));
  925.                     if memError <> noErr then
  926.                         ExitWithError('There is not enough memory to create the expression.');
  927.                     size := size + 20;
  928.                 end;
  929.             exp^^[count].bracket := ' ';
  930.             NewNode := count;
  931.             count := count + 1;
  932.         end;
  933.     function CreateUnaryOpNode (theOp: unaryOpKinds;
  934.                                     operand: integer): integer;
  935.         var
  936.             loc: integer;
  937.         begin
  938.             loc := NewNode;
  939.             exp^^[loc].kind := unaryOpNode;
  940.             exp^^[loc].theOp := theOp;
  941.             exp^^[loc].operand := operand;
  942.             CreateUnaryOpNode := loc;
  943.         end;
  944.     function CreateBinOpNode (theOp: binOpKinds;
  945.                                     operand1, operand2: integer): integer;
  946.         var
  947.             loc: integer;
  948.         begin
  949.             loc := NewNode;
  950.             exp^^[loc].kind := binOpNode;
  951.             exp^^[loc].theBinOp := theOp;
  952.             exp^^[loc].operand1 := operand1;
  953.             exp^^[loc].operand2 := operand2;
  954.             CreateBinOpNode := loc;
  955.         end;
  956.     procedure expression (var loc: integer;
  957.                                     var logical: boolean);
  958.     forward;
  959.     procedure primary (var loc: integer;
  960.                                     var logical: boolean);
  961.         var
  962.             tok, brak, saveTok: SymbolName;
  963.             symb: integer;
  964.             err: SymbolTableError;
  965.             loc2, loc3, loc4, i: integer;
  966.         procedure CheckBracket (saveTok, tok: SymbolName);
  967.             begin
  968.                 if (saveTok = '(') then begin
  969.                         if (tok <> ')') then
  970.                             ExitWithError('Expected to find a ")" to match a previous "(".');
  971.                     end
  972.                 else if (saveTok = '{') then begin
  973.                         if (tok <> '}') then
  974.                             ExitWithError('Expected to find a "}" to match a previous "{".');
  975.                     end
  976.                 else if (saveTok = '[') then begin
  977.                         if (tok <> ']') then
  978.                             ExitWithError('Expected to find a "]" to match a previous "[".');
  979.                     end;
  980.             end;
  981.         begin
  982.             GetToken(tok);
  983.             if tok = numericToken then begin
  984.                     loc := NewNode;
  985.                     exp^^[loc].kind := constantNode;
  986.                     exp^^[loc].value := tokenVal;
  987.                     logical := false;
  988.                 end
  989.             else if tok = 'π' then begin
  990.                     loc := NewNode;
  991.                     exp^^[loc].kind := piNode;
  992.                     logical := false;
  993.                 end
  994.             else if tok[1] in ['a'..'z', 'A'..'Z'] then begin
  995.                     logical := false;
  996.                     symb := FindSymb(tok);
  997.                     if symb = -1 then
  998.                         if autoDeclareVariables then begin
  999.                                 symb := CreateSymbol(tok, variableSymbol, err);
  1000.                                 if err <> noSymbolTableError then
  1001.                                     ExitWithError('Ran out of memory while trying to declare a new variable.');
  1002.                             end
  1003.                         else
  1004.                             ExitWithError('Unknown name found in expression.');
  1005.                     case ST^^[symb].kind of
  1006.                         variableSymbol:  begin
  1007.                                 loc := NewNode;
  1008.                                 exp^^[loc].kind := variableNode;
  1009.                                 exp^^[loc].symbol := symb
  1010.                             end;
  1011.                         constantSymbol:  begin
  1012.                                 loc := NewNode;
  1013.                                 exp^^[loc].kind := symbolicConstantNode;
  1014.                                 exp^^[loc].symbol := symb
  1015.                             end;
  1016.                         parameterSymbol:  begin
  1017.                                 loc := NewNode;
  1018.                                 exp^^[loc].kind := parameterNode;
  1019.                                 exp^^[loc].number := ST^^[symb].paramNum
  1020.                             end;
  1021.                         functionSymbol, builtInFunctionSymbol:  begin
  1022.                                 Look(brak);
  1023.                                 if (brak <> '(') & (parenthesesOnly | ((brak <> '{') & (brak <> '['))) then
  1024.                                     if parenthesesOnly then
  1025.                                         ExitWithError('The argument to a function must be enclosed in parenthesis.')
  1026.                                     else
  1027.                                         ExitWithError('The argument to a function must be enclosed in parenthesis, brackets, or braces.');
  1028.                                 if ST^^[symb].kind = builtInFunctionSymbol then begin
  1029.                                         GetToken(saveTok);
  1030.                                         expression(loc, logical);
  1031.                                         if logical then
  1032.                                             ExitWithError('The argument to a function cannot be a boolean value.');
  1033.                                         exp^^[loc].bracket := saveTok;
  1034.                                         GetToken(tok);
  1035.                                         CheckBracket(saveTok, tok);
  1036.                                         loc := CreateUnaryOpNode(ST^^[symb].theOp, loc);
  1037.                                     end
  1038.                                 else begin
  1039.                                         GetToken(brak);
  1040.                                         loc := NewNode;
  1041.                                         exp^^[loc].kind := functNode;
  1042.                                         exp^^[loc].definition := symb;
  1043.                                         exp^^[loc].bracket := brak;
  1044.                                         loc2 := loc;
  1045.                                         for i := 1 to ST^^[symb].parameterCount do begin
  1046.                                                 expression(loc3, logical);
  1047.                                                 if logical then
  1048.                                                     ExitWithError('The argument to a function cannot be a boolean value.');
  1049.                                                 loc4 := NewNode;
  1050.                                                 exp^^[loc4].kind := actualParamNode;
  1051.                                                 exp^^[loc4].param := loc3;
  1052.                                                 exp^^[loc4].nextArgument := -1;
  1053.                                                 if i = 1 then
  1054.                                                     exp^^[loc2].firstArgument := loc4
  1055.                                                 else
  1056.                                                     exp^^[loc2].nextArgument := loc4;
  1057.                                                 loc2 := loc4;
  1058.                                                 GetToken(tok);
  1059.                                                 if i < ST^^[symb].parameterCount then begin
  1060.                                                         if (tok = ')') | (tok = '}') | (tok = ']') then
  1061.                                                             ExitWithError('Not enough parameters provided for function.')
  1062.                                                         else if tok <> ',' then
  1063.                                                             ExitWithError('A comma is required between parameters of function.');
  1064.                                                     end
  1065.                                                 else begin
  1066.                                                         if tok = ',' then
  1067.                                                             ExitWithError('Too many parameters provided for function.');
  1068.                                                     end;
  1069.                                             end;
  1070.                                         CheckBracket(saveTok, tok);
  1071.                                     end;
  1072.                             end;
  1073.                     end;
  1074.                 end
  1075.             else if (tok = '(') | (not parenthesesOnly & ((tok = '{') | (tok = '['))) then begin
  1076.                     saveTok := tok;
  1077.                     expression(loc, logical);
  1078.                     exp^^[loc].bracket := saveTok;
  1079.                     GetToken(tok);
  1080.                     if (saveTok = '(') then begin
  1081.                             if (tok <> ')') then
  1082.                                 ExitWithError('Expected to find a ")" to match a previous "(".');
  1083.                         end
  1084.                     else if (saveTok = '{') then begin
  1085.                             if (tok <> '}') then
  1086.                                 ExitWithError('Expected to find a "}" to match a previous "{".');
  1087.                         end
  1088.                     else if (saveTok = '[') then begin
  1089.                             if (tok <> ']') then
  1090.                                 ExitWithError('Expected to find a "]" to match a previous "[".');
  1091.                         end
  1092.                 end
  1093.             else if tok = caseToken then begin
  1094.                     loc2 := -1;
  1095.                     loc := NewNode;
  1096.                     i := loc;
  1097.                     repeat
  1098.                         exp^^[i].kind := splitFunctionNode;
  1099.                         expression(loc3, logical);
  1100.                         if not logical then
  1101.                             ExitWithError('The conditions in a split function must be boolean expressions.');
  1102.                         GetToken(tok);
  1103.                         if tok <> ':' then
  1104.                             ExitWithError('The condition in a split function must be followed by a ":".');
  1105.                         expression(loc4, logical);
  1106.                         if logical then
  1107.                             ExitWithError('You can''t use a boolean expression to compute the value of a split function.');
  1108.                         if loc2 <> -1 then
  1109.                             exp^^[loc2].nextCase := i;
  1110.                         exp^^[i].kind := splitFunctionNode;
  1111.                         exp^^[i].theTest := loc3;
  1112.                         exp^^[i].theExpression := loc4;
  1113.                         exp^^[i].nextCase := -1;
  1114.                         loc2 := i;
  1115.                         GetToken(tok);
  1116.                         if tok = ';' then begin
  1117.                                 look(tok);
  1118.                                 if Tok = endToken then
  1119.                                     GetToken(tok);
  1120.                             end
  1121.                         else if tok <> endToken then
  1122.                             ExitWithError('You need either a ";" or an "end" here.');
  1123.                         if tok <> endToken then
  1124.                             i := NewNode;
  1125.                     until tok = endToken;
  1126.                 end
  1127.             else if tok = endOfDataToken then
  1128.                 ExitWithError('Incomplete expression; end of data found in middle of expression.')
  1129.             else if tok = badNumericToken then
  1130.                 ExitWithError('An illegally formed number was found.')
  1131.             else if tok = errorToken then
  1132.                 ExitWithError('Illegal item found in expression.')
  1133.             else
  1134.                 ExitWithError('Misplaced symbol found in expression.');
  1135.         end;
  1136.     procedure factorial (var loc: integer;
  1137.                                     var logical: boolean);
  1138.         var
  1139.             next: integer;
  1140.             tok: SymbolName;
  1141.         begin
  1142.             primary(loc, logical);
  1143.             if allowFactorials then begin
  1144.                     look(tok);
  1145.                     if (tok = '!') & logical then
  1146.                         ExitWithError('You can''t use the factorial operation on a boolean expression.');
  1147.                     while tok = '!' do begin
  1148.                             GetToken(tok);
  1149.                             loc := CreateUnaryOpNode(factorialOp, loc);
  1150.                             look(tok);
  1151.                         end;
  1152.                 end;
  1153.         end;
  1154.     procedure factor (var loc: integer;
  1155.                                     var logical: boolean);
  1156.         var
  1157.             next: integer;
  1158.             tok: SymbolName;
  1159.         begin
  1160.             factorial(loc, logical);
  1161.             look(tok);
  1162.             if logical & (tok = '^') then
  1163.                 ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
  1164.             while tok = '^' do begin
  1165.                     GetToken(tok);
  1166.                     factorial(next, logical);
  1167.                     if logical then
  1168.                         ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
  1169.                     loc := CreateBinOpNode(powerOp, loc, next);
  1170.                     look(tok);
  1171.                 end;
  1172.         end;
  1173.     procedure term (var loc: integer;
  1174.                                     var logical: boolean);
  1175.         var
  1176.             next: integer;
  1177.             tok: SymbolName;
  1178.         begin
  1179.             factor(loc, logical);
  1180.             look(tok);
  1181.             if implicitMultiplication & (tok[1] in ['a'..'z', 'A'..'Z', '0'..'9', '[', '{', '(', numericToken]) then
  1182.                 tok := implicitStarToken;
  1183.             if logical & ((tok = '*') | (tok = '/') | (tok = implicitStarToken)) then
  1184.                 ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
  1185.             while (tok = '*') | (tok = '/') | (tok = implicitStarToken) do begin
  1186.                     if tok <> implicitStarToken then
  1187.                         GetToken(tok);
  1188.                     factor(next, logical);
  1189.                     if logical then
  1190.                         ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
  1191.                     if tok = '/' then
  1192.                         loc := CreateBinOpNode(divideOp, loc, next)
  1193.                     else
  1194.                         loc := CreateBinOpNode(timesOp, loc, next);
  1195.                     look(tok);
  1196.                     if implicitMultiplication & (tok[1] in ['a'..'z', 'A'..'Z', '0'..'9', '[', '{', '(', numericToken]) then
  1197.                         tok := implicitStarToken;
  1198.                 end;
  1199.         end;
  1200.     procedure basicExp (var loc: integer;
  1201.                                     var logical: boolean);
  1202.         var
  1203.             next: integer;
  1204.             tok, leadingTok: SymbolName;
  1205.         begin
  1206.             look(leadingTok);
  1207.             if (leadingTok = '+') | (leadingTok = '-') then
  1208.                 GetToken(tok);
  1209.             term(loc, logical);
  1210.             if (leadingTok = '+') | (leadingTok = '-') then begin
  1211.                     if logical then
  1212.                         ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
  1213.                     if leadingTok = '-' then
  1214.                         loc := CreateunaryOpNode(unaryMinusOp, loc);
  1215.                 end;
  1216.             look(tok);
  1217.             if logical & ((tok = '+') | (tok = '-')) then
  1218.                 ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
  1219.             while (tok = '+') | (tok = '-') do begin
  1220.                     GetToken(tok);
  1221.                     term(next, logical);
  1222.                     if logical then
  1223.                         ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
  1224.                     if tok = '+' then
  1225.                         loc := CreateBinOpNode(plusOp, loc, next)
  1226.                     else
  1227.                         loc := CreateBinOpNode(minusOp, loc, next);
  1228.                     look(tok);
  1229.                 end;
  1230.         end;
  1231.     procedure comparison (var loc: integer;
  1232.                                     var logical: boolean);
  1233.         var
  1234.             loc2: integer;
  1235.             tok: SymbolName;
  1236.             theOp: binOpKinds;
  1237.         begin
  1238.             BasicExp(loc, logical);
  1239.             look(tok);
  1240.             if tok[1] in ['<', '>', '=', '≤', '≥', '≠'] then begin
  1241.                     if logical then
  1242.                         ExitWithError('You can''t apply a comparison operator to a boolean expression.');
  1243.                     GetToken(tok);
  1244.                     BasicExp(loc2, logical);
  1245.                     if logical then
  1246.                         ExitWithError('You can''t apply a comparison operator to a boolean expression.');
  1247.                     case tok[1] of
  1248.                         '<': 
  1249.                             theOp := ltOp;
  1250.                         '>': 
  1251.                             theOp := gtOp;
  1252.                         '=': 
  1253.                             theOp := eqOp;
  1254.                         '≤': 
  1255.                             theOp := leOp;
  1256.                         '≥': 
  1257.                             theOp := geOp;
  1258.                         '≠': 
  1259.                             theOp := neOp;
  1260.                     end;
  1261.                     loc := CreateBinOpNode(theOp, loc, loc2);
  1262.                     logical := true;
  1263.                 end;
  1264.         end;
  1265.     procedure NotExp (var loc: integer;
  1266.                                     var logical: boolean);
  1267.         var
  1268.             next: integer;
  1269.             tok: SymbolName;
  1270.             ct: integer;
  1271.         begin
  1272.             ct := 0;
  1273.             look(tok);
  1274.             while tok = '~' do begin
  1275.                     GetToken(tok);
  1276.                     ct := ct + 1;
  1277.                     look(tok);
  1278.                 end;
  1279.             if ct = 0 then
  1280.                 comparison(loc, logical)
  1281.             else begin
  1282.                     comparison(loc, logical);
  1283.                     if not logical then
  1284.                         ExitWithError('You can''t use the NOT operator on an arithmetic expression.');
  1285.                     if odd(ct) then
  1286.                         loc := CreateUnaryOpNode(notOp, loc);
  1287.                 end;
  1288.         end;
  1289.     procedure andExp (var loc: integer;
  1290.                                     var logical: boolean);
  1291.         var
  1292.             next: integer;
  1293.             tok: SymbolName;
  1294.         begin
  1295.             notExp(loc, logical);
  1296.             look(tok);
  1297.             if not logical & (tok = '&') then
  1298.                 ExitWithError('You can''t use a boolean operator with an arithmetic expression.');
  1299.             while tok = '&' do begin
  1300.                     GetToken(tok);
  1301.                     notExp(next, logical);
  1302.                     if not logical then
  1303.                         ExitWithError('You can''t use a boolean operator with an arithmetic expression.');
  1304.                     loc := CreateBinOpNode(andOp, loc, next);
  1305.                     look(tok);
  1306.                 end;
  1307.         end;
  1308.     procedure expression (var loc: integer;
  1309.                                     var logical: boolean);
  1310.         var
  1311.             next: integer;
  1312.             tok: SymbolName;
  1313.         begin
  1314.             andExp(loc, logical);
  1315.             look(tok);
  1316.             if not logical & (tok = '|') then
  1317.                 ExitWithError('You can''t use a boolean operator with an arithmetic expression.');
  1318.             while tok = '|' do begin
  1319.                     GetToken(tok);
  1320.                     andExp(next, logical);
  1321.                     if not logical then
  1322.                         ExitWithError('You can''t use a boolean operator with an arithmetic expression.');
  1323.                     loc := CreateBinOpNode(orOp, loc, next);
  1324.                     look(tok);
  1325.                 end;
  1326.         end;
  1327.         var
  1328.             logical: boolean;
  1329.             tok: SymbolName;
  1330.             loc: integer;
  1331.     begin
  1332.         parseData := CharsPtr(definition);
  1333.         parseSize := charCount;
  1334.         pos := 0;
  1335.         tokenAvailable := false;
  1336.         data := NewHandle(10 * SizeOf(expressionNode));
  1337.         exp := ExpressionListHandle(data);
  1338.         if memError <> noErr then begin
  1339.                 errorPosition := 0;
  1340.                 errorMessage := 'There is not enough memory to create expression.';
  1341.                 EXIT(create);
  1342.             end;
  1343.         size := 10;
  1344.         count := 0;
  1345.         expression(loc, logical);
  1346.         first := loc;
  1347.         if logical then
  1348.             ExitWithError('A boolean-valued expression is not legal here.');
  1349.         Look(tok);
  1350.         if (tok <> EndOfDataToken) & not extraDataAfterExpression then
  1351.             ExitWithError('Extra data found after the end of the expression.');
  1352.         SetHandleSize(data, count * SizeOf(expressionNode));
  1353.         errorPosition := -1;
  1354.     end;
  1355.  
  1356. procedure expression.createFromString (definition: string;
  1357.                                 var errorPosition: integer;   { -1 if no error }
  1358.                                 var errorMessage: string);
  1359.     begin
  1360.         if definition = '' then begin
  1361.                 errorPosition := 0;
  1362.                 errorMessage := 'Empty input provided for expression definition.';
  1363.             end
  1364.         else
  1365.             create(@definition[1], length(definition), errorPosition, errorMessage);
  1366.     end;
  1367.  
  1368. procedure expression.createFromText (definition: CharsHandle;
  1369.                                 var errorPosition: integer;   { -1 if no error }
  1370.                                 var errorMessage: string);
  1371.     begin
  1372.         HLock(Handle(definition));
  1373.         create(Pointer(definition^), CharsSize(definition), errorPosition, errorMessage);
  1374.         HUnlock(Handle(definition));
  1375.     end;
  1376. {$PUSH}
  1377. {$R-}
  1378.  
  1379.  
  1380. {$S ExtraExpressionStuff }
  1381.  
  1382. procedure RealToString (x: extended;
  1383.                                 var s: string);
  1384.     var
  1385.         n, i: integer;
  1386.     begin
  1387.         if x = errorVal then
  1388.             s := '(ERROR)'
  1389.         else if abs(x) <= infinityRecip then
  1390.             s := '0'
  1391.         else if abs(x) >= infinity then
  1392.             s := '?'
  1393.         else if (abs(x) >= 5e8) or (abs(x) < 5e-8) then begin  { exponential form }
  1394.                 n := 15;
  1395.                 repeat  { this is needed since the stupid computer alllows 4 spaces for the exponent even if it is one two or three digits }
  1396.                     s := StringOf(x : n);
  1397.                     n := n - 1;
  1398.                     i := length(s);
  1399.                     while (i > 0) & (s[i] = ' ') do
  1400.                         i := i - 1;
  1401.                     s[0] := chr(i);
  1402.                 until (length(s) <= 12) | (n = 11)
  1403.             end
  1404.         else begin
  1405.                 s := StringOf(x : 1 : 10);
  1406.                 i := length(s);
  1407.                 while (i > 0) & (s[i] = '0') do   { strip off trailing zeros }
  1408.                     i := i - 1;
  1409.                 if (i > 0) & (s[i] = '.') then  { strip off terminating decimal point }
  1410.                     i := i - 1;
  1411.                 if i > 12 then  { maximum length allowed for output is 12}
  1412.                     s[0] := chr(12)
  1413.                 else
  1414.                     s[0] := chr(i);
  1415.             end
  1416.     end;
  1417.  
  1418. {$POP}
  1419.  
  1420. procedure expression.GetPrintText (var theText: CharsHandle);
  1421.     var
  1422.         countCh: integer;
  1423.         exp: ExpressionListHandle;
  1424.     procedure AddString (str: string);
  1425.         var
  1426.             i: integer;
  1427.         begin
  1428.             if countCh + length(str) > GetHandleSize(handle(theText)) then
  1429.                 SetHandleSize(handle(theText), countCh + length(str) + 25);
  1430.             if memError <> noErr then begin
  1431.                     SetHandleSize(handle(theText), count);
  1432.                     EXIT(GetPrintText);
  1433.                 end;
  1434.             for i := 1 to length(str) do begin
  1435.                     theText^^[countCh] := str[i];
  1436.                     countCh := countCh + 1;
  1437.                 end;
  1438.         end;
  1439.     function BinName (op: BinOpKinds): string;
  1440.         begin
  1441.             case op of
  1442.                 plusOp: 
  1443.                     BinName := ' + ';
  1444.                 minusOp: 
  1445.                     BinName := ' - ';
  1446.                 timesOp: 
  1447.                     BinName := '*';
  1448.                 divideOp: 
  1449.                     BinName := '/';
  1450.                 powerOp: 
  1451.                     BinName := '^';
  1452.                 andOp: 
  1453.                     BinName := ' AND ';
  1454.                 orOp: 
  1455.                     BinName := ' OR ';
  1456.                 leOp: 
  1457.                     BinName := ' ≤ ';
  1458.                 ltOp: 
  1459.                     BinName := ' < ';
  1460.                 geOp: 
  1461.                     BinName := ' ≥ ';
  1462.                 gtOp: 
  1463.                     BinName := ' > ';
  1464.                 eqOp: 
  1465.                     BinName := ' = ';
  1466.                 neOp: 
  1467.                     BinName := ' ≠ ';
  1468.             end;
  1469.         end;
  1470.     function UnaryName (op: UnaryOpKinds): string;
  1471.         begin
  1472.             case op of
  1473.                 unaryMinusOp: 
  1474.                     UnaryName := '-';
  1475.                 notOp: 
  1476.                     UnaryName := ' NOT ';
  1477.                 sinOp: 
  1478.                     UnaryName := 'sin';
  1479.                 cosOp: 
  1480.                     UnaryName := 'cos';
  1481.                 tanOp: 
  1482.                     UnaryName := 'tan';
  1483.                 cotOp: 
  1484.                     UnaryName := 'cot';
  1485.                 secOp: 
  1486.                     UnaryName := 'sec';
  1487.                 cscOp: 
  1488.                     UnaryName := 'csc';
  1489.                 arcsinOp: 
  1490.                     UnaryName := 'arcsin';
  1491.                 arctanOp: 
  1492.                     UnaryName := 'arctan';
  1493.                 expOp: 
  1494.                     UnaryName := 'exp';
  1495.                 lnOp: 
  1496.                     UnaryName := 'ln';
  1497.                 roundOp: 
  1498.                     UnaryName := 'round';
  1499.                 truncOp: 
  1500.                     UnaryName := 'trunc';
  1501.                 sqrtOp: 
  1502.                     UnaryName := 'sqrt';
  1503.                 cubertOp: 
  1504.                     UnaryName := 'cubeRt';
  1505.                 absOp: 
  1506.                     UnaryName := 'abs';
  1507.             end;
  1508.         end;
  1509.     procedure MakeStr (loc: integer);
  1510.         var
  1511.             i, symb, prm: integer;
  1512.             name: SymbolName;
  1513.             str: string;
  1514.         begin
  1515.             if (exp^^[loc].bracket <> ' ') & (exp^^[loc].kind <> functNode) then
  1516.                 AddString(exp^^[loc].bracket);
  1517.             case exp^^[loc].kind of
  1518.                 binOpNode:  begin
  1519.                         MakeStr(exp^^[loc].operand1);
  1520.                         AddString(BinName(exp^^[loc].theBinOp));
  1521.                         MakeStr(exp^^[loc].operand2);
  1522.                     end;
  1523.                 unaryOpNode: 
  1524.                     if exp^^[loc].theOp = factorialOp then begin
  1525.                             MakeStr(exp^^[loc].operand);
  1526.                             AddString('!');
  1527.                         end
  1528.                     else begin
  1529.                             AddString(UnaryName(exp^^[loc].theOp));
  1530.                             MakeStr(exp^^[loc].operand);
  1531.                         end;
  1532.                 functNode:  begin
  1533.                         symb := exp^^[loc].definition;
  1534.                         name := ST^^[symb].name;
  1535.                         AddString(name);
  1536.                         AddString(exp^^[loc].bracket);
  1537.                         prm := exp^^[loc].firstArgument;
  1538.                         for i := 1 to ST^^[symb].paramNum do begin
  1539.                                 if exp^^[prm].kind <> actualParamNode then
  1540.                                     Halt; { ??? }
  1541.                                 MakeStr(exp^^[prm].Param);
  1542.                                 if i < ST^^[symb].paramNum then begin
  1543.                                         AddString(', ');
  1544.                                         prm := exp^^[prm].nextArgument;
  1545.                                     end;
  1546.                             end;
  1547.                         AddString(RightBracket(exp^^[loc].bracket))
  1548.                     end;
  1549.                 splitFunctionNode:  begin
  1550.                         AddString(' CASE ');
  1551.                         i := loc;
  1552.                         repeat
  1553.                             MakeStr(exp^^[i].theTest);
  1554.                             AddString(' : ');
  1555.                             MakeStr(exp^^[i].theExpression);
  1556.                             i := exp^^[i].nextCase;
  1557.                             if i >= 0 then
  1558.                                 AddString(';  ');
  1559.                         until i < 0;
  1560.                         AddString(' END ');
  1561.                     end;
  1562.                 variableNode, symbolicConstantNode:  begin
  1563.                         name := ST^^[exp^^[loc].symbol].name;
  1564.                         AddString(name);
  1565.                     end;
  1566.                 constantNode:  begin
  1567.                         RealToString(exp^^[loc].value, str);
  1568.                         AddString(str);
  1569.                     end;
  1570.                 piNode: 
  1571.                     AddString('π');
  1572.             end;
  1573.             if (exp^^[loc].bracket <> ' ') & (exp^^[loc].kind <> functNode) then
  1574.                 AddString(RightBracket(exp^^[loc].bracket));
  1575.         end;
  1576.     begin
  1577.         countCh := 0;
  1578.         exp := ExpressionListHandle(data);
  1579.         MakeStr(first);
  1580.         SetHandleSize(handle(theText), countCh);
  1581.     end;
  1582.  
  1583. procedure expression.GetPrintString (var str: string;
  1584.                                 var lengthExceeded: boolean);
  1585.     var
  1586.         theText: CharsHandle;
  1587.         i: integer;
  1588.         top: longint;
  1589.     begin
  1590.         theText := CharsHandle(NewHandle(25));
  1591.         GetPrintText(theText);
  1592.         top := GetHandleSize(Handle(theText));
  1593.         if top > 255 then begin
  1594.                 lengthExceeded := true;
  1595.                 top := 255;
  1596.             end
  1597.         else
  1598.             lengthExceeded := false;
  1599.         str := '';
  1600.         for i := 0 to top - 1 do
  1601.             str := Concat(str, theText^^[i]);
  1602.         DisposHandle(Handle(theText));
  1603.     end;
  1604.  
  1605. procedure expression.kill;
  1606.     begin
  1607.         DisposHandle(data);
  1608.         data := nil;
  1609.         dispose(self);
  1610.     end;
  1611.  
  1612. function power (x: extended;
  1613.                                 n: integer): extended;
  1614. { compute x^n;  n MUST be >= 0 !!!}
  1615.     var
  1616.         v: extended;
  1617.     begin
  1618.         v := 1;
  1619.         while n > 0 do begin
  1620.                 if odd(n) then begin
  1621.                         v := v * x;
  1622.                         if abs(v) > infinity then begin
  1623.                                 v := infinity;
  1624.                                 leave
  1625.                             end;
  1626.                     end;
  1627.                 n := Bsr(n, 1);
  1628.                 x := sqr(x);
  1629.             end;
  1630.         power := v;
  1631.     end;
  1632.  
  1633.  
  1634.     type
  1635.         intListArray = array[0..100] of integer;
  1636.         intListPtr = ^IntListArray;
  1637.         intListHandle = ^IntListPtr;
  1638.         ParamData = array[1..10] of extended;
  1639.  
  1640.  
  1641. function computeValue (e: expressionListHandle;
  1642.                                 first: integer;
  1643.                                 var cases: Handle;
  1644.                                 var caseCt, caseSize: integer;
  1645.                                 var context: ParamData): extended;
  1646.     var
  1647.         caseData: IntListHandle;
  1648.         i, j, k: integer;
  1649.     function GetVal (loc: integer): extended;
  1650.         var
  1651.             theCase: longint;
  1652.         function BinVal (op: binOpKinds;
  1653.                                         x, y: extended): extended;
  1654.             var
  1655.                 temp: extended;
  1656.                 Apply2: extended;
  1657.             begin
  1658.                 if op = orOp then begin
  1659.                         if x <> 0 then
  1660.                             Apply2 := x
  1661.                         else
  1662.                             Apply2 := y
  1663.                     end
  1664.                 else if op = andOp then begin
  1665.                         if (x = 0) then
  1666.                             Apply2 := 0
  1667.                         else
  1668.                             Apply2 := y
  1669.                     end
  1670.                 else begin
  1671.                         if (x = errorVal) or (y = errorVal) then begin
  1672.                                 if op in [eqOp, ltOp, gtOp, NEOp, LEOp, GEOp] then
  1673.                                     Apply2 := 0
  1674.                                 else
  1675.                                     Apply2 := errorVal;
  1676.                             end
  1677.                         else if (x = infinity) or (y = infinity) then begin
  1678.                                 if op in [eqOp, ltOp, gtOp, NEOp, LEOp, GEOp] then
  1679.                                     Apply2 := 0
  1680.                                 else
  1681.                                     Apply2 := infinity;
  1682.                             end
  1683.                         else if op in [plusOp, minusOp, timesOp, powerOp, divideOp] then begin
  1684.                                 case op of
  1685.                                     plusOp: 
  1686.                                         temp := x + y;
  1687.                                     minusOP: 
  1688.                                         temp := x - y;
  1689.                                     timesOp: 
  1690.                                         temp := x * y;
  1691.                                     divideOp: 
  1692.                                         if (abs(y) < infinityRecip) | (abs(x) > abs(infinity * y)) then begin
  1693.                                                 temp := infinity;
  1694.                                                 theCase := 0;
  1695.                                             end
  1696.                                         else begin
  1697.                                                 temp := x / y;
  1698.                                                 theCase := ord(y > 0)
  1699.                                             end;
  1700.                                     powerOp: 
  1701.                                         if abs(y) <= infinityRecip then begin
  1702.                                                 if abs(x) <= infinityRecip then begin
  1703.                                                         temp := infinity;
  1704.                                                         theCase := 0;
  1705.                                                     end
  1706.                                                 else begin
  1707.                                                         temp := 1;
  1708.                                                         theCase := ord(x > 0)
  1709.                                                     end
  1710.                                             end
  1711.                                         else if (abs(y) <= 32000) & (abs(round(y) - y) < 1e-5) then begin
  1712.                                                 temp := power(x, abs(round(y)));
  1713.                                                 if y < 0 then
  1714.                                                     if abs(temp) < infinityRecip then
  1715.                                                         temp := infinity
  1716.                                                     else
  1717.                                                         temp := 1 / temp;
  1718.                                                 if y < 0 then
  1719.                                                     if x = 0 then
  1720.                                                         theCase := 0
  1721.                                                     else
  1722.                                                         theCase := ord(x > 0);
  1723.                                             end
  1724.                                         else begin
  1725.                                                 if x = 0 then begin
  1726.                                                         temp := 0;
  1727.                                                         theCase := 0
  1728.                                                     end
  1729.                                                 else if x < 0 then begin
  1730.                                                         temp := errorVal;
  1731.                                                         theCase := -1
  1732.                                                     end
  1733.                                                 else begin
  1734.                                                         temp := y * ln(x);
  1735.                                                         if temp < -4000 then
  1736.                                                             temp := 0
  1737.                                                         else if temp > 4000 then
  1738.                                                             temp := infinity
  1739.                                                         else
  1740.                                                             temp := exp(temp);
  1741.                                                         theCase := 1
  1742.                                                     end;
  1743.                                             end;
  1744.                                 end;
  1745.                                 if abs(temp) > infinity then
  1746.                                     Apply2 := infinity
  1747.                                 else
  1748.                                     Apply2 := temp
  1749.                             end
  1750.                         else
  1751.                             case op of
  1752.                                 eqOp: 
  1753.                                     Apply2 := ord(x = y);
  1754.                                 ltOp: 
  1755.                                     Apply2 := ord(x < y);
  1756.                                 gtOp: 
  1757.                                     Apply2 := ord(x > y);
  1758.                                 GEOp: 
  1759.                                     Apply2 := ord(x >= y);
  1760.                                 LEOp: 
  1761.                                     Apply2 := ord(x <= y);
  1762.                                 NEOp: 
  1763.                                     Apply2 := ord(x <> y);
  1764.                             end
  1765.                     end;
  1766.                 BinVal := Apply2
  1767.             end;
  1768.         function UnaryVal (op: unaryOpKinds;
  1769.                                         x: extended): extended;
  1770.        { handle the evaluation of a unary operator or built-in function at x}
  1771.             var
  1772.                 temp: extended;
  1773.                 i: integer;
  1774.                 apply1: extended;
  1775.             begin
  1776.                 if (abs(x) >= infinity) then
  1777.                     Apply1 := x
  1778.                 else begin
  1779.                         case op of
  1780.                             unaryMinusOp: 
  1781.                                 Apply1 := -x;
  1782.                             factorialOp:  begin
  1783.                                     if (x < -infinityRecip) | (x > 1000) | (abs(x - round(x)) > 1e-10) then begin
  1784.                                             apply1 := errorVal;
  1785.                                             theCase := 1000;
  1786.                                         end
  1787.                                     else begin
  1788.                                             apply1 := 1;
  1789.                                             for i := 2 to round(x) do begin
  1790.                                                     apply1 := apply1 * i;
  1791.                                                     if apply1 > infinity then begin
  1792.                                                             apply1 := infinity;
  1793.                                                             leave;
  1794.                                                         end;
  1795.                                                 end;
  1796.                                             theCase := round(x);
  1797.                                         end
  1798.                                 end;
  1799.                             sinOp: 
  1800.                                 Apply1 := sin(x);
  1801.                             cosOp: 
  1802.                                 Apply1 := cos(x);
  1803.                             secOp:  begin
  1804.                                     temp := cos(x);
  1805.                                     if abs(temp) <= infinityRecip then begin
  1806.                                             Apply1 := infinity;
  1807.                                             theCase := 0
  1808.                                         end
  1809.                                     else begin
  1810.                                             Apply1 := 1 / temp;
  1811.                                             theCase := ord(temp > 0)
  1812.                                         end;
  1813.                                 end;
  1814.                             cscOp:  begin
  1815.                                     temp := sin(x);
  1816.                                     if abs(temp) <= infinityRecip then begin
  1817.                                             Apply1 := infinity;
  1818.                                             theCase := 0;
  1819.                                         end
  1820.                                     else begin
  1821.                                             Apply1 := 1 / temp;
  1822.                                             theCase := ord(temp > 0)
  1823.                                         end;
  1824.                                 end;
  1825.                             tanOp:  begin
  1826.                                     temp := cos(x);
  1827.                                     if abs(temp) <= infinityRecip then begin
  1828.                                             Apply1 := infinity;
  1829.                                             theCase := 0;
  1830.                                         end
  1831.                                     else begin
  1832.                                             Apply1 := sin(x) / temp;
  1833.                                             theCase := ord(temp > 0)
  1834.                                         end;
  1835.                                 end;
  1836.                             cotOp:  begin
  1837.                                     temp := sin(x);
  1838.                                     if abs(temp) <= infinityRecip then begin
  1839.                                             Apply1 := infinity;
  1840.                                             theCase := 0
  1841.                                         end
  1842.                                     else begin
  1843.                                             Apply1 := cos(x) / temp;
  1844.                                             theCase := ord(temp > 0)
  1845.                                         end;
  1846.                                 end;
  1847.                             arctanOp: 
  1848.                                 Apply1 := arctan(x);
  1849.                             arcsinOp: 
  1850.                                 if abs(x) > 1 then begin
  1851.                                         Apply1 := errorVal;
  1852.                                         theCase := 0
  1853.                                     end
  1854.                                 else begin
  1855.                                         theCase := 1;
  1856.                                         if abs(x - 1) < 1e-10 then
  1857.                                             Apply1 := 2 * arctan(1)
  1858.                                         else if abs(x + 1) < 1e-10 then
  1859.                                             Apply1 := -2 * arctan(1)
  1860.                                         else
  1861.                                             Apply1 := arctan(x / sqrt(1 - sqr(x)));
  1862.                                     end;
  1863.                             lnOp:  begin
  1864.                                     if x <= 0 then
  1865.                                         Apply1 := errorVal
  1866.                                     else
  1867.                                         Apply1 := ln(x);
  1868.                                     theCase := ord(x > 0);
  1869.                                 end;
  1870.                             expOp: 
  1871.                                 if x > 4000 then
  1872.                                     Apply1 := infinity
  1873.                                 else if x < -4000 then
  1874.                                     Apply1 := 0
  1875.                                 else
  1876.                                     Apply1 := exp(x);
  1877.                             absOp:  begin
  1878.                                     Apply1 := abs(x);
  1879.                                     if x = 0 then
  1880.                                         theCase := 0
  1881.                                     else
  1882.                                         theCase := ord(x > 0)
  1883.                                 end;
  1884.                             truncOp: 
  1885.                                 if abs(x) >= Maxlongint - 1 then
  1886.                                     Apply1 := errorVal
  1887.                                 else begin
  1888.                                         Apply1 := trunc(x);
  1889.                                         theCase := trunc(x)
  1890.                                     end;
  1891.                             roundOp: 
  1892.                                 if abs(x) >= Maxlongint - 1 then
  1893.                                     Apply1 := errorVal
  1894.                                 else begin
  1895.                                         Apply1 := round(x);
  1896.                                         theCase := round(x)
  1897.                                     end;
  1898.                             sqrtOp:  begin
  1899.                                     if x < 0 then
  1900.                                         Apply1 := errorVal
  1901.                                     else
  1902.                                         Apply1 := sqrt(x);
  1903.                                     theCase := ord(x >= 0);
  1904.                                 end;
  1905.                             cubertOp: 
  1906.                                 if abs(x) < infinityRecip then
  1907.                                     Apply1 := 0
  1908.                                 else if x < 0 then
  1909.                                     Apply1 := -exp(ln(-x) / 3)
  1910.                                 else
  1911.                                     Apply1 := exp(ln(x) / 3);
  1912.                         end;
  1913.                         if (abs(x) >= infinity) & (x <> errorVal) then
  1914.                             UnaryVal := infinity
  1915.                         else
  1916.                             UnaryVal := apply1
  1917.                     end;
  1918.             end;
  1919.         function FunctVal: extended;
  1920.             var
  1921.                 newContext: ParamData;
  1922.                 symb, i, ct: integer;
  1923.             begin
  1924.                 symb := e^^[loc].definition;
  1925.                 i := e^^[loc].firstArgument;
  1926.                 for ct := 1 to ST^^[symb].parameterCount do begin
  1927.                         newcontext[ct] := GetVal(e^^[i].param);
  1928.                         i := e^^[i].nextArgument;
  1929.                     end;
  1930.                 with ST^^[symb].definition do
  1931.                     FunctVal := ComputeValue(expressionListHandle(data), first, cases, caseCt, caseSize, newcontext);
  1932.             end;
  1933.             var
  1934.                 x, y: extended;
  1935.                 uOp: unaryOpKinds;
  1936.                 bOp: BinOpkinds;
  1937.                 symb: integer;
  1938.                 done: boolean;
  1939.                 ct, i: integer;
  1940.         begin
  1941.             theCase := maxlongint;
  1942.             case e^^[loc].kind of
  1943.                 binOpNode:  begin
  1944.                         x := GetVal(e^^[loc].operand1);
  1945.                         y := GetVal(e^^[loc].operand2);
  1946.                         bOp := e^^[loc].theBinOP;
  1947.                         GetVal := BinVal(bOp, x, y);
  1948.                     end;
  1949.                 unaryOpNode:  begin
  1950.                         x := GetVal(e^^[loc].operand);
  1951.                         uOp := e^^[loc].theOp;
  1952.                         GetVal := UnaryVal(uOp, x);
  1953.                     end;
  1954.                 constantNode: 
  1955.                     GetVal := e^^[loc].value;
  1956.                 variableNode, symbolicConstantNode:  begin
  1957.                         symb := e^^[loc].symbol;
  1958.                         GetVal := ST^^[symb].value
  1959.                     end;
  1960.                 splitFunctionNode:  begin
  1961.                         ct := 0;
  1962.                         done := false;
  1963.                         repeat
  1964.                             i := e^^[loc].theTest;
  1965.                             done := GetVal(i) <> 0;
  1966.                             if done then
  1967.                                 GetVal := GetVal(e^^[loc].theExpression)
  1968.                             else
  1969.                                 loc := e^^[loc].nextCase;
  1970.                             ct := ct + 1;
  1971.                         until done | (loc = -1);
  1972.                         if loc = -1 then
  1973.                             GetVal := errorVal;
  1974.                         theCase := ct;
  1975.                     end;
  1976.                 functNode: 
  1977.                     GetVal := FunctVal;
  1978.                 parameterNode: 
  1979.                     GetVal := context[e^^[loc].number];
  1980.                 piNode: 
  1981.                     GetVal := pi;
  1982.             end;
  1983.             if (cases <> nil) & (theCase <> maxlongint) then begin
  1984.                     if caseSize = caseCt then begin
  1985.                             caseSize := caseSize + 20;
  1986.                             SetHandleSize(cases, caseSize * SizeOf(Integer));
  1987.                         end;
  1988.                     if abs(theCase) > maxint then
  1989.                         theCase := maxint;
  1990.                     caseData^^[caseCt] := theCase;
  1991.                     caseCt := caseCt + 1;
  1992.                 end;
  1993.         end;
  1994.     begin
  1995.         caseData := IntListHandle(cases);
  1996.         ComputeValue := getVal(first);
  1997.     end;
  1998.  
  1999. function expression.value: extended;
  2000.     var
  2001.         noCases: handle;
  2002.         junk: paramData;
  2003.     begin
  2004.         noCases := nil;
  2005.         value := ValueWithCases(noCases)
  2006.     end;
  2007.  
  2008. function expression.valueWithCases (var cases: handle): extended;
  2009.     var
  2010.         junk: paramData;
  2011.         casesCt, casesSize: integer;
  2012.     begin
  2013.         if cases <> nil then
  2014.             SetHandleSize(cases, 10 * SizeOf(Integer));
  2015.         casesCt := 0;
  2016.         casesSize := 10;
  2017.         valueWithCases := ComputeValue(expressionListHandle(self.data), self.first, cases, casesCt, casesSize, junk);
  2018.         if cases <> nil then
  2019.             SetHandleSize(cases, casesCt * SizeOf(Integer));
  2020.     end;
  2021.  
  2022.  
  2023. function sameCases (cases1, cases2: handle): boolean;
  2024.     var
  2025.         ct, i: integer;
  2026.     begin
  2027.         ct := GetHandleSize(cases1);
  2028.         if (ct <> GetHandleSize(cases2)) | (ct mod SizeOf(Integer) <> 0) then
  2029.             sameCases := false
  2030.         else begin
  2031.                 sameCases := true;
  2032.                 for i := 0 to (ct div SizeOf(Integer)) - 1 do
  2033.                     if intListHandle(cases1)^^[i] <> intListHandle(cases2)^^[i] then begin
  2034.                             sameCases := false;
  2035.                             Exit(sameCases);
  2036.                         end;
  2037.             end;
  2038.     end;
  2039.  
  2040. function expression.isConstant: boolean;
  2041.     var
  2042.         e: ExpressionListHandle;
  2043.     function constant (loc: integer): boolean;
  2044.         var
  2045.             def: integer;
  2046.         begin
  2047.             case e^^[loc].kind of
  2048.                 binOpNode: 
  2049.                     constant := constant(e^^[loc].operand1) & constant(e^^[loc].operand2);
  2050.                 unaryOpNode: 
  2051.                     constant := constant(e^^[loc].operand);
  2052.                 functNode:  begin
  2053.                         def := e^^[loc].definition;
  2054.                         loc := e^^[loc].firstArgument;
  2055.                         while loc <> -1 do
  2056.                             if constant(e^^[loc].param) then
  2057.                                 loc := e^^[loc].nextArgument
  2058.                             else begin
  2059.                                     constant := false;
  2060.                                     EXIT(constant)
  2061.                                 end;
  2062.                         constant := true;
  2063.                     end;
  2064.                 splitFunctionNode:  begin
  2065.                         if not (constant(e^^[loc].theTest) & constant(e^^[loc].theExpression)) then
  2066.                             constant := false
  2067.                         else if e^^[loc].nextCase = -1 then
  2068.                             constant := true
  2069.                         else
  2070.                             constant := constant(e^^[loc].nextCase);
  2071.                     end;
  2072.                 variableNode: 
  2073.                     constant := false;
  2074.                 symbolicConstantNode, constantNode, piNode: 
  2075.                     constant := true;
  2076.             end;
  2077.         end;
  2078.     begin
  2079.         e := ExpressionListHandle(data);
  2080.         isConstant := constant(first);
  2081.     end;
  2082.  
  2083.  
  2084. end.